home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 May / Macworld (1998-05).dmg / Serious Demos / TeamWave 3.0 / TeamWave Workplace / TeamWave Workplace.rsrc / TEXT_15_Console.txt < prev    next >
Text File  |  1998-02-13  |  12KB  |  482 lines
  1. # console.tcl --
  2. #
  3. # This code constructs the console window for an application.  It
  4. # can be used by non-unix systems that do not have built-in support
  5. # for shells.
  6. #
  7. # SCCS: @(#) console.tcl 1.45 97/09/17 16:52:40
  8. #
  9. # Copyright (c) 1995-1997 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. # TODO: history - remember partially written command
  16.  
  17. # tkConsoleInit --
  18. # This procedure constructs and configures the console windows.
  19. #
  20. # Arguments:
  21. #     None.
  22.  
  23. proc tkConsoleInit {} {
  24.     global tcl_platform
  25.  
  26.     if {! [consoleinterp eval {set tcl_interactive}]} {
  27.     wm withdraw .
  28.     }
  29.  
  30.     if {"$tcl_platform(platform)" == "macintosh"} {
  31.     set mod "Cmd"
  32.     } else {
  33.     set mod "Ctrl"
  34.     }
  35.  
  36.     menu .menubar
  37.     .menubar add cascade -label File -menu .menubar.file -underline 0
  38.     .menubar add cascade -label Edit -menu .menubar.edit -underline 0
  39.  
  40.     menu .menubar.file -tearoff 0
  41.     .menubar.file add command -label "Source..." -underline 0 \
  42.     -command tkConsoleSource
  43.     .menubar.file add command -label "Hide Console" -underline 0 \
  44.     -command {wm withdraw .}
  45.     if {"$tcl_platform(platform)" == "macintosh"} {
  46.     .menubar.file add command -label "Quit" -command exit -accel Cmd-Q
  47.     } else {
  48.     .menubar.file add command -label "Exit" -underline 1 -command exit
  49.     }
  50.  
  51.     menu .menubar.edit -tearoff 0
  52.     .menubar.edit add command -label "Cut" -underline 2 \
  53.     -command { event generate .console <<Cut>> } -accel "$mod+X"
  54.     .menubar.edit add command -label "Copy" -underline 0 \
  55.     -command { event generate .console <<Copy>> } -accel "$mod+C"
  56.     .menubar.edit add command -label "Paste" -underline 1 \
  57.     -command { event generate .console <<Paste>> } -accel "$mod+V"
  58.  
  59.     if {"$tcl_platform(platform)" == "windows"} {
  60.     .menubar.edit add command -label "Delete" -underline 0 \
  61.         -command { event generate .console <<Clear>> } -accel "Del"
  62.  
  63.     .menubar add cascade -label Help -menu .menubar.help -underline 0
  64.     menu .menubar.help -tearoff 0
  65.     .menubar.help add command -label "About..." -underline 0 \
  66.         -command tkConsoleAbout
  67.     } else {
  68.     .menubar.edit add command -label "Clear" -underline 2 \
  69.         -command { event generate .console <<Clear>> }
  70.     }
  71.  
  72.     . conf -menu .menubar
  73.  
  74.     text .console  -yscrollcommand ".sb set" -setgrid true 
  75.     scrollbar .sb -command ".console yview"
  76.     pack .sb -side right -fill both
  77.     pack .console -fill both -expand 1 -side left
  78.     if {$tcl_platform(platform) == "macintosh"} {
  79.         .console configure -font {Monaco 9 normal} -highlightthickness 0
  80.     }
  81.  
  82.     tkConsoleBind .console
  83.  
  84.     .console tag configure stderr -foreground red
  85.     .console tag configure stdin -foreground blue
  86.  
  87.     focus .console
  88.     
  89.     wm protocol . WM_DELETE_WINDOW { wm withdraw . }
  90.     wm title . "Console"
  91.     flush stdout
  92.     .console mark set output [.console index "end - 1 char"]
  93.     tkTextSetCursor .console end
  94.     .console mark set promptEnd insert
  95.     .console mark gravity promptEnd left
  96. }
  97.  
  98. # tkConsoleSource --
  99. #
  100. # Prompts the user for a file to source in the main interpreter.
  101. #
  102. # Arguments:
  103. # None.
  104.  
  105. proc tkConsoleSource {} {
  106.     set filename [tk_getOpenFile -defaultextension .tcl -parent . \
  107.               -title "Select a file to source" \
  108.               -filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}]
  109.     if {"$filename" != ""} {
  110.         set cmd [list source $filename]
  111.     if [catch {consoleinterp eval $cmd} result] {
  112.         tkConsoleOutput stderr "$result\n"
  113.     }
  114.     }
  115. }
  116.  
  117. # tkConsoleInvoke --
  118. # Processes the command line input.  If the command is complete it
  119. # is evaled in the main interpreter.  Otherwise, the continuation
  120. # prompt is added and more input may be added.
  121. #
  122. # Arguments:
  123. # None.
  124.  
  125. proc tkConsoleInvoke {args} {
  126.     set ranges [.console tag ranges input]
  127.     set cmd ""
  128.     if {$ranges != ""} {
  129.     set pos 0
  130.     while {[lindex $ranges $pos] != ""} {
  131.         set start [lindex $ranges $pos]
  132.         set end [lindex $ranges [incr pos]]
  133.         append cmd [.console get $start $end]
  134.         incr pos
  135.     }
  136.     }
  137.     if {$cmd == ""} {
  138.     tkConsolePrompt
  139.     } elseif [info complete $cmd] {
  140.     .console mark set output end
  141.     .console tag delete input
  142.     set result [consoleinterp record $cmd]
  143.     if {$result != ""} {
  144.         .console insert insert "$result\n"
  145.     }
  146.     tkConsoleHistory reset
  147.     tkConsolePrompt
  148.     } else {
  149.     tkConsolePrompt partial
  150.     }
  151.     .console yview -pickplace insert
  152. }
  153.  
  154. # tkConsoleHistory --
  155. # This procedure implements command line history for the
  156. # console.  In general is evals the history command in the
  157. # main interpreter to obtain the history.  The global variable
  158. # histNum is used to store the current location in the history.
  159. #
  160. # Arguments:
  161. # cmd -    Which action to take: prev, next, reset.
  162.  
  163. set histNum 1
  164. proc tkConsoleHistory {cmd} {
  165.     global histNum
  166.     
  167.     switch $cmd {
  168.         prev {
  169.         incr histNum -1
  170.         if {$histNum == 0} {
  171.         set cmd {history event [expr [history nextid] -1]}
  172.         } else {
  173.         set cmd "history event $histNum"
  174.         }
  175.             if {[catch {consoleinterp eval $cmd} cmd]} {
  176.                 incr histNum
  177.                 return
  178.             }
  179.         .console delete promptEnd end
  180.             .console insert promptEnd $cmd {input stdin}
  181.         }
  182.         next {
  183.         incr histNum
  184.         if {$histNum == 0} {
  185.         set cmd {history event [expr [history nextid] -1]}
  186.         } elseif {$histNum > 0} {
  187.         set cmd ""
  188.         set histNum 1
  189.         } else {
  190.         set cmd "history event $histNum"
  191.         }
  192.         if {$cmd != ""} {
  193.         catch {consoleinterp eval $cmd} cmd
  194.         }
  195.         .console delete promptEnd end
  196.         .console insert promptEnd $cmd {input stdin}
  197.         }
  198.         reset {
  199.             set histNum 1
  200.         }
  201.     }
  202. }
  203.  
  204. # tkConsolePrompt --
  205. # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
  206. # exists in the main interpreter it will be called to generate the 
  207. # prompt.  Otherwise, a hard coded default prompt is printed.
  208. #
  209. # Arguments:
  210. # partial -    Flag to specify which prompt to print.
  211.  
  212. proc tkConsolePrompt {{partial normal}} {
  213.     if {$partial == "normal"} {
  214.     set temp [.console index "end - 1 char"]
  215.     .console mark set output end
  216.         if [consoleinterp eval "info exists tcl_prompt1"] {
  217.             consoleinterp eval "eval \[set tcl_prompt1\]"
  218.         } else {
  219.             puts -nonewline "% "
  220.         }
  221.     } else {
  222.     set temp [.console index output]
  223.     .console mark set output end
  224.         if [consoleinterp eval "info exists tcl_prompt2"] {
  225.             consoleinterp eval "eval \[set tcl_prompt2\]"
  226.         } else {
  227.         puts -nonewline "> "
  228.         }
  229.     }
  230.     flush stdout
  231.     .console mark set output $temp
  232.     tkTextSetCursor .console end
  233.     .console mark set promptEnd insert
  234.     .console mark gravity promptEnd left
  235. }
  236.  
  237. # tkConsoleBind --
  238. # This procedure first ensures that the default bindings for the Text
  239. # class have been defined.  Then certain bindings are overridden for
  240. # the class.
  241. #
  242. # Arguments:
  243. # None.
  244.  
  245. proc tkConsoleBind {win} {
  246.     bindtags $win "$win Text . all"
  247.  
  248.     # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
  249.     # Otherwise, if a widget binding for one of these is defined, the
  250.     # <KeyPress> class binding will also fire and insert the character,
  251.     # which is wrong.  Ditto for <Escape>.
  252.  
  253.     bind $win <Alt-KeyPress> {# nothing }
  254.     bind $win <Meta-KeyPress> {# nothing}
  255.     bind $win <Control-KeyPress> {# nothing}
  256.     bind $win <Escape> {# nothing}
  257.     bind $win <KP_Enter> {# nothing}
  258.  
  259.     bind $win <Tab> {
  260.     tkConsoleInsert %W \t
  261.     focus %W
  262.     break
  263.     }
  264.     bind $win <Return> {
  265.     %W mark set insert {end - 1c}
  266.     tkConsoleInsert %W "\n"
  267.     tkConsoleInvoke
  268.     break
  269.     }
  270.     bind $win <Delete> {
  271.     if {[%W tag nextrange sel 1.0 end] != ""} {
  272.         %W tag remove sel sel.first promptEnd
  273.     } else {
  274.         if [%W compare insert < promptEnd] {
  275.         break
  276.         }
  277.     }
  278.     }
  279.     bind $win <BackSpace> {
  280.     if {[%W tag nextrange sel 1.0 end] != ""} {
  281.         %W tag remove sel sel.first promptEnd
  282.     } else {
  283.         if [%W compare insert <= promptEnd] {
  284.         break
  285.         }
  286.     }
  287.     }
  288.     foreach left {Control-a Home} {
  289.     bind $win <$left> {
  290.         if [%W compare insert < promptEnd] {
  291.         tkTextSetCursor %W {insert linestart}
  292.         } else {
  293.         tkTextSetCursor %W promptEnd
  294.             }
  295.         break
  296.     }
  297.     }
  298.     foreach right {Control-e End} {
  299.     bind $win <$right> {
  300.         tkTextSetCursor %W {insert lineend}
  301.         break
  302.     }
  303.     }
  304.     bind $win <Control-d> {
  305.     if [%W compare insert < promptEnd] {
  306.         break
  307.     }
  308.     }
  309.     bind $win <Control-k> {
  310.     if [%W compare insert < promptEnd] {
  311.         %W mark set insert promptEnd
  312.     }
  313.     }
  314.     bind $win <Control-t> {
  315.     if [%W compare insert < promptEnd] {
  316.         break
  317.     }
  318.     }
  319.     bind $win <Meta-d> {
  320.     if [%W compare insert < promptEnd] {
  321.         break
  322.     }
  323.     }
  324.     bind $win <Meta-BackSpace> {
  325.     if [%W compare insert <= promptEnd] {
  326.         break
  327.     }
  328.     }
  329.     bind $win <Control-h> {
  330.     if [%W compare insert <= promptEnd] {
  331.         break
  332.     }
  333.     }
  334.     foreach prev {Control-p Up} {
  335.     bind $win <$prev> {
  336.         tkConsoleHistory prev
  337.         break
  338.     }
  339.     }
  340.     foreach prev {Control-n Down} {
  341.     bind $win <$prev> {
  342.         tkConsoleHistory next
  343.         break
  344.     }
  345.     }
  346.     bind $win <Insert> {
  347.     catch {tkConsoleInsert %W [selection get -displayof %W]}
  348.     break
  349.     }
  350.     bind $win <KeyPress> {
  351.     tkConsoleInsert %W %A
  352.     break
  353.     }
  354.     foreach left {Control-b Left} {
  355.     bind $win <$left> {
  356.         if [%W compare insert == promptEnd] {
  357.         break
  358.         }
  359.         tkTextSetCursor %W insert-1c
  360.         break
  361.     }
  362.     }
  363.     foreach right {Control-f Right} {
  364.     bind $win <$right> {
  365.         tkTextSetCursor %W insert+1c
  366.         break
  367.     }
  368.     }
  369.     bind $win <F9> {
  370.     eval destroy [winfo child .]
  371.     if {$tcl_platform(platform) == "macintosh"} {
  372.         source -rsrc Console
  373.     } else {
  374.         source [file join $tk_library console.tcl]
  375.     }
  376.     }
  377.     bind $win <<Cut>> {
  378.         # Same as the copy event
  379.      if {![catch {set data [%W get sel.first sel.last]}]} {
  380.         clipboard clear -displayof %W
  381.         clipboard append -displayof %W $data
  382.     }
  383.     break
  384.     }
  385.     bind $win <<Copy>> {
  386.      if {![catch {set data [%W get sel.first sel.last]}]} {
  387.         clipboard clear -displayof %W
  388.         clipboard append -displayof %W $data
  389.     }
  390.     break
  391.     }
  392.     bind $win <<Paste>> {
  393.     catch {
  394.         set clip [selection get -displayof %W -selection CLIPBOARD]
  395.         set list [split $clip \n\r]
  396.         tkConsoleInsert %W [lindex $list 0]
  397.         foreach x [lrange $list 1 end] {
  398.         %W mark set insert {end - 1c}
  399.         tkConsoleInsert %W "\n"
  400.         tkConsoleInvoke
  401.         tkConsoleInsert %W $x
  402.         }
  403.     }
  404.     break
  405.     }
  406. }
  407.  
  408. # tkConsoleInsert --
  409. # Insert a string into a text at the point of the insertion cursor.
  410. # If there is a selection in the text, and it covers the point of the
  411. # insertion cursor, then delete the selection before inserting.  Insertion
  412. # is restricted to the prompt area.
  413. #
  414. # Arguments:
  415. # w -        The text window in which to insert the string
  416. # s -        The string to insert (usually just a single character)
  417.  
  418. proc tkConsoleInsert {w s} {
  419.     if {$s == ""} {
  420.     return
  421.     }
  422.     catch {
  423.     if {[$w compare sel.first <= insert]
  424.         && [$w compare sel.last >= insert]} {
  425.         $w tag remove sel sel.first promptEnd
  426.         $w delete sel.first sel.last
  427.     }
  428.     }
  429.     if {[$w compare insert < promptEnd]} {
  430.     $w mark set insert end    
  431.     }
  432.     $w insert insert $s {input stdin}
  433.     $w see insert
  434. }
  435.  
  436. # tkConsoleOutput --
  437. #
  438. # This routine is called directly by ConsolePutsCmd to cause a string
  439. # to be displayed in the console.
  440. #
  441. # Arguments:
  442. # dest -    The output tag to be used: either "stderr" or "stdout".
  443. # string -    The string to be displayed.
  444.  
  445. proc tkConsoleOutput {dest string} {
  446.     .console insert output $string $dest
  447.     .console see insert
  448. }
  449.  
  450. # tkConsoleExit --
  451. #
  452. # This routine is called by ConsoleEventProc when the main window of
  453. # the application is destroyed.  Don't call exit - that probably already
  454. # happened.  Just delete our window.
  455. #
  456. # Arguments:
  457. # None.
  458.  
  459. proc tkConsoleExit {} {
  460.     destroy .
  461. }
  462.  
  463. # tkConsoleAbout --
  464. #
  465. # This routine displays an About box to show Tcl/Tk version info.
  466. #
  467. # Arguments:
  468. # None.
  469.  
  470. proc tkConsoleAbout {} {
  471.     global tk_patchLevel
  472.     tk_messageBox -type ok -message "Tcl for Windows
  473. Copyright \251 1996 Sun Microsystems, Inc.
  474.  
  475. Tcl [info patchlevel]
  476. Tk $tk_patchLevel"
  477. }
  478.  
  479. # now initialize the console
  480.  
  481. tkConsoleInit
  482.